﻿module Base
open System
open fs
open Base
type Printer = { Name: string }
//        module Zip =
//            let copyDirectory s d =
//                let shell = Shell32.ShellClass()
//                (shell.NameSpace d).CopyHere (shell.NameSpace s, 0)
//                System.Runtime.InteropServices.Marshal.FinalReleaseComObject shell
//            let create o i =
////                let ZipFile = "D:\\C-ProgramFiles.zip"
//                Text.writeAll o ("PK\x05\x06" + new String (char 0, 18))
//                copyDirectory i o
module XDocument =
    open System.Xml.Linq
    let load file = XDocument.Load (file: string)
    let e name a = XElement (XName.Get name, a)
    let a name a = XAttribute (XName.Get name, a)
//module Web =
//    open System.Web
//    module HttpContext =
//        module Current =
//            module Server =
//                let mapPath path = HttpContext.Current.Server.MapPath path
open Text
//module Interop =
//    open System.Runtime.InteropServices
//    module Kernel =
//        module Import =
//            // typedef struct _SECURITY_ATTRIBUTES {DWORD nLength;LPVOID lpSecurityDescriptor;BOOL bInheritHandle;} SECURITY_ATTRIBUTES, *PSECURITY_ATTRIBUTES, *LPSECURITY_ATTRIBUTES;
//            type SECURITY_ATTRIBUTES = { nLength: uint32; lpSecurityDescriptor: nativeint; bInheritHandle: bool }
//            // typedef enum _SECURITY_IMPERSONATION_LEVEL {SecurityAnonymous,SecurityIdentification,SecurityImpersonation,SecurityDelegation} SECURITY_IMPERSONATION_LEVEL, *PSECURITY_IMPERSONATION_LEVEL;
//            and SECURITY_IMPERSONATION_LEVEL = SecurityAnonymous | SecurityIdentification | SecurityImpersonation | SecurityDelegation
//            // typedef enum tagTOKEN_TYPE {TokenPrimary = 1,TokenImpersonation} TOKEN_TYPE, *PTOKEN_TYPE;
//            and TOKEN_TYPE = TokenPrimary = 1 | TokenImpersonation = 2
//            // typedef struct _STARTUPINFO {DWORD cb;LPTSTR lpReserved;LPTSTR lpDesktop;LPTSTR lpTitle;DWORD dwX;DWORD dwY;DWORD dwXSize;DWORD dwYSize;DWORD dwXCountChars;DWORD dwYCountChars;DWORD dwFillAttribute;DWORD dwFlags;WORD wShowWindow;WORD cbReserved2;LPBYTE lpReserved2;HANDLE hStdInput;HANDLE hStdOutput;HANDLE hStdError;} STARTUPINFO, *LPSTARTUPINFO;
//            and STARTUPINFO = { cb: uint32; lpReserved: string; lpDesktop: string; lpTitle: string; dwX: uint32; dwY: uint32; dwXSize: uint32; dwYSize: uint32; dwXCountChars: uint32; dwYCountChars: uint32; dwFillAttribute: uint32; dwFlags: uint32; wShowWindow: uint16; cbReserved2: uint16; lpReserved2: byte; hStdInput: nativeint; hStdOutput: nativeint; hStdError: nativeint }
//            // typedef struct _PROCESS_INFORMATION {HANDLE hProcess;HANDLE hThread;DWORD dwProcessId;DWORD dwThreadId;} PROCESS_INFORMATION, *LPPROCESS_INFORMATION;
//            and PROCESS_INFORMATION = { hProcess: nativeint; hThread: nativeint; dwProcessId: uint32; dwThreadId: uint32 }
//
//            and TokenAccessRights = READ_CONTROL = 0x20000 | STANDARD_RIGHTS_REQUIRED = 0xF0000 | STANDARD_RIGHTS_READ = 0x20000 | STANDARD_RIGHTS_WRITE = 0x20000 | STANDARD_RIGHTS_EXECUTE = 0x20000 | STANDARD_RIGHTS_ALL = 0x1F0000 | SPECIFIC_RIGHTS_ALL = 0xFFFF | TOKEN_ASSIGN_PRIMARY = 0x1 | TOKEN_DUPLICATE = 0x2 | TOKEN_IMPERSONATE = 0x4 | TOKEN_QUERY = 0x8 | TOKEN_QUERY_SOURCE = 0x10 | TOKEN_ADJUST_PRIVILEGES = 0x20 | TOKEN_ADJUST_GROUPS = 0x40 | TOKEN_ADJUST_DEFAULT = 0x80 | TOKEN_ADJUST_SESSIONID = 0x100
//            and ProcessAccessRights = All = 0x1F0FFF | Terminate = 0x1 | CreateThread = 0x2 | VMOperation = 0x8 | VMRead = 0x10 | VMWrite = 0x20 | DupHandle = 0x40 | SetInformation = 0x200 | QueryInformation = 0x400 | Synchronize = 0x100000
//
//            // DWORD WTSGetActiveConsoleSessionId(void);
//            [<DllImport("kernel32")>] extern uint32 WTSGetActiveConsoleSessionId()
//            // BOOL ProcessIdToSessionId(__in DWORD dwProcessId, __out DWORD *pSessionId);
//            [<DllImport("kernel32")>] extern bool ProcessIdToSessionId([<In>] uint32 dwProcessId, [<Out>] uint32 *pSessionId)
//            // HANDLE WINAPI OpenProcess(__in DWORD dwDesiredAccess, __in BOOL bInheritHandle, __in DWORD dwProcessId);
//            [<DllImport("kernel32")>] extern nativeint OpenProcess([<In>] ProcessAccessRights dwDesiredAccess, [<In>] bool bInheritHandle, [<In>] uint32 dwProcessId)
//            // BOOL WINAPI OpenProcessToken(__in HANDLE ProcessHandle, __in DWORD DesiredAccess, __out PHANDLE TokenHandle);
//            [<DllImport("kernel32")>] extern bool OpenProcessToken([<In>] nativeint ProcessHandle, [<In>] TokenAccessRights DesiredAccess, [<Out>] nativeint TokenHandle)
//            // BOOL WINAPI CloseHandle(__in HANDLE hObject);
//            [<DllImport("kernel32")>] extern bool CloseHandle([<In>] nativeint hObject)
//            // BOOL WINAPI DuplicateTokenEx(__in HANDLE hExistingToken,__in DWORD dwDesiredAccess,__in_opt LPSECURITY_ATTRIBUTES lpTokenAttributes,__in SECURITY_IMPERSONATION_LEVEL ImpersonationLevel,__in TOKEN_TYPE TokenType,__out PHANDLE phNewToken);
//            [<DllImport("kernel32")>] extern bool DuplicateTokenEx([<In>] nativeint hExistingToken, [<In>] uint32 dwDesiredAccess, [<In; Optional>] SECURITY_ATTRIBUTES lpTokenAttributes, [<In>] SECURITY_IMPERSONATION_LEVEL ImpersonationLevel, [<In>] TOKEN_TYPE TokenType, [<Out>] nativeint phNewToken)
//            // BOOL WINAPI CreateEnvironmentBlock(__out LPVOID *lpEnvironment,__in_opt HANDLE hToken,__in BOOL bInherit);
//            [<DllImport("kernel32")>] extern bool CreateEnvironmentBlock([<Out>] nativeint *lpEnvironment, [<In; Optional>] nativeint hToken, [<In>] bool bInherit)
//            // BOOL WINAPI CreateProcessAsUser(__in_opt HANDLE hToken,__in_opt LPCTSTR lpApplicationName,__inout_opt LPTSTR lpCommandLine,__in_opt LPSECURITY_ATTRIBUTES lpProcessAttributes,__in_opt LPSECURITY_ATTRIBUTES lpThreadAttributes,__in BOOL bInheritHandles,__in DWORD dwCreationFlags,__in_opt LPVOID lpEnvironment,__in_opt LPCTSTR lpCurrentDirectory,__in LPSTARTUPINFO lpStartupInfo,__out LPPROCESS_INFORMATION lpProcessInformation);
//            [<DllImport("kernel32")>] extern bool CreateProcessAsUser([<In; Optional>] nativeint hToken, [<In; Optional>] string lpApplicationName, [<In; Out; Optional>] string lpCommandLine, [<In; Optional>] SECURITY_ATTRIBUTES lpProcessAttributes, [<In; Optional>] SECURITY_ATTRIBUTES lpThreadAttributes, [<In>] bool bInheritHandles, [<In>] uint32 dwCreationFlags, [<In; Optional>] nativeint lpEnvironment, [<In; Optional>] string lpCurrentDirectory, [<In>] STARTUPINFO lpStartupInfo, [<Out>] PROCESS_INFORMATION lpProcessInformation)
//            // BOOL WINAPI DestroyEnvironmentBlock(__in LPVOID lpEnvironment);
//            [<DllImport("kernel32")>] extern bool DestroyEnvironmentBlock([<In>] nativeint lpEnvironment)
//
//            let getEnvironmentBlock(sProcess, dwSession) =
//                let dwAccess = TokenAccessRights.TOKEN_DUPLICATE ||| TokenAccessRights.TOKEN_QUERY
//                let mutable hSessionId = uint32 -1
//                let mutable processPID = uint32 -1
//                let mutable hProc = nativeint -1
//                let hToken = nativeint -1
//                let mutable pEnvBlock = nativeint -1
//                for _process in Process.getProcessesByName sProcess do
//                    ProcessIdToSessionId(uint32 _process.Id, &&hSessionId) |> ignore
//                    if dwSession = hSessionId then processPID <- uint32 _process.Id
//                if processPID = uint32 -1 then nativeint 0
//                else
//                    hProc <- OpenProcess(ProcessAccessRights.All, false, processPID)
//                    if hProc = nativeint -1 then nativeint 0
//                    else
//                        OpenProcessToken(hProc, dwAccess, nativeint hToken) |> ignore
//                        if hToken = nativeint -1 then
//                            CloseHandle(hProc) |> ignore
//                            nativeint 0
//                        elif CreateEnvironmentBlock(&&pEnvBlock, hToken, true) then
//                            CloseHandle(hProc) |> ignore
//                            CloseHandle(hToken) |> ignore
//                            pEnvBlock
//                        else
//                            CloseHandle(hProc) |> ignore
//                            CloseHandle(hToken) |> ignore
//                            nativeint 0
module CodeDom =
    type Attribute = { Name: string; Source: System.Attribute }
//    and Type = { Name: string; IsGenericType: bool; GenericTypeDefinition: Type; GenericArguments: Type array } with
//        member r.GetGenericTypeDefinition() = r.GenericTypeDefinition
//        member r.GetGenericArguments() = r.GenericArguments
//        member r.MakeGenericType(v) = r.GenericTypeDefinition
//        static member (==) (v : Type, a: System.Type) = true
//        static member parse (a: System.Type) = { Type.Name = a.Name; IsGenericType = a.IsGenericType; GenericTypeDefinition = Type.parse (a.GetGenericTypeDefinition()); GenericArguments = (a.GetGenericArguments() |> Seq.map (fun a -> Type.parse a) |> Seq.toArray)  }
    and RecordValue = { Name: string; Type: Type; Attributes: seq<Attribute> }
    and Record = { Name: string; Values: seq<RecordValue>; Attributes: seq<Attribute> }
    and EnumerationValue = { Name: string; Literal: int }
    and Enumeration = { Name: string; Values: seq<EnumerationValue> }
    and Module = { Name: string; Enumerations: seq<Enumeration>; Records: seq<Record> }
module Reflection =
    open System.Reflection
    module Assembly =
        type r = { Name: string; Types: seq<Type>; Source: Assembly } with member a.Item(b) = a.Types |> Seq.find (fun a -> a.FullName = b)
        let getTypes (assembly: Assembly) = assembly.GetTypes()
        let r (a: Assembly) = { Name = a.GetName().Name; Types = getTypes a; Source = a }
        let load name = r (Assembly.Load (name: string))
        let loadFile path = r (Assembly.LoadFile path)
        let loadFrom path = r (Assembly.LoadFrom path)
        let getExecutingAssembly _ = r (Assembly.GetCallingAssembly())
    let getSelfOrSeqElementType (r: Type) = if r.IsGenericType then r.GetGenericArguments()|> Seq.head else r
    let getProperties (t: Type) = t.GetProperties()
    let getEnumValues = Enum.GetValues
    let isModule (t: Type) = t.IsDefined(typeof<CompilationMappingAttribute>, false) && (t.GetCustomAttributes(typeof<CompilationMappingAttribute>, false).[0] :?> CompilationMappingAttribute).SourceConstructFlags = SourceConstructFlags.Module
    let getValue v (p: PropertyInfo) = p.GetValue (v, Array.empty<obj>)
module Mapping =
    open Reflection
    open CodeDom
    let getAttributes (v: MemberInfo) = v.GetCustomAttributes(false) |> Seq.map (fun a -> { Attribute.Name = a.GetType().Name; Source = a :?> System.Attribute })
    let ``type`` (v: Type) = if v.IsGenericType && v.GetGenericTypeDefinition().GUID = typeof<Nullable<_>>.GUID then typeof<Microsoft.FSharp.Core.Option<_>>.GetGenericTypeDefinition().MakeGenericType(v.GetGenericArguments().[0]) else v
    let toRecordValues (properties: seq<PropertyInfo>) = seq { for property in properties do yield { Name = property.Name; Type = ``type`` property.PropertyType; Attributes = getAttributes property } }
    let getRecordValues ``type`` = toRecordValues <| getProperties ``type``
    let toRecords (types: seq<Type>) =
        let getAttributes (v: Type) = getAttributes v |> Seq.filter (fun a -> a.Name <> "SerializableAttribute")
        seq { for t in types |> Seq.filter (fun a -> not(Seq.isEmpty(getProperties(a)))) do yield { Record.Name = t.Name; Values = getRecordValues t; Attributes = getAttributes t } }
    let toEnumerationValues (values: Array) = seq { for a in values do yield { Name = a.ToString(); Literal = a :?> int } }
    let getEnumerationValues ``type`` = toEnumerationValues <| getEnumValues ``type``
    let toEnumerations (types: seq<Type>) = seq { for t in types do yield { Enumeration.Name = t.Name; Values = getEnumerationValues t } }
    module CodeGereation =
        let value v = if v = null then "null" else if v.GetType().IsEnum then sprintf "%s.%A" (v.GetType().Name) v else sprintf "%A" v
        let namedParameter (p: PropertyInfo) o = sprintf "%s = %s" (toCamel(p.Name)) (value (p.GetValue(o, null)))
        let namedParameters (v: seq<PropertyInfo>) o = if Seq.isEmpty v then "" elif Seq.length v = 1 then " " + (value ((Seq.head v).GetValue(o, null))) else sprintf "(%s)" (v |> Seq.map (fun a -> namedParameter a o) |> String.concat ", ")
        let attribute (v: Attribute) = sprintf "[<%s%s>]" (if v.Name.EndsWith "Attribute" then v.Name.Remove (v.Name.Length - "Attribute".Length) else v.Name) (namedParameters (v.Source.GetType().GetProperties() |> Seq.filter (fun a -> a.Name <> "TypeId")) v.Source)
        let attributes (v: seq<Attribute>) = if Seq.isEmpty v then "" else (v |> Seq.map (fun a -> attribute a) |> String.concat "") + " "
        let rec ``type`` v =
            if v = typeof<string> then "string"
            elif v = typeof<bool> then "bool"
            elif v = typeof<int> then "int"
            elif v = typeof<decimal> then "decimal"
            elif v.IsGenericType then
                if v.GetGenericTypeDefinition() = typeof<Option<_>>.GetGenericTypeDefinition() then ``type`` (v.GetGenericArguments().[0]) + " option"
                elif v.GetGenericTypeDefinition() = typeof<seq<_>>.GetGenericTypeDefinition() then sprintf "seq<%s>" (``type`` (v.GetGenericArguments().[0]))
                elif v.GetGenericTypeDefinition() = typeof<System.Collections.Generic.IList<_>>.GetGenericTypeDefinition() then sprintf "IList<%s>" (``type`` (v.GetGenericArguments().[0])) else v.Name
            else v.Name
        module Record =
            module Value =
                let splitLine (v: RecordValue) = sprintf "\r\n        %s%s: %s" (attributes v.Attributes) v.Name (``type`` v.Type)
            let value (v: RecordValue) = sprintf " %s%s: %s" (attributes v.Attributes) v.Name (``type`` v.Type)
            let values (v: seq<RecordValue>) = v |> Seq.map (fun v -> value v) |> String.concat ";" |> sprintf "%s "
        let record (v: Record) = sprintf "%s%s = {%s}" (attributes v.Attributes) v.Name (Record.values v.Values)
        let records (v: seq<Record>) = sprintf "    type %s" (v |> Seq.map (fun v -> record v) |> String.concat "\r\n    and ")
        module Enumeration =
            let value (v: EnumerationValue) = sprintf "%s = %i" v.Name v.Literal
            let values (v: seq<EnumerationValue>) = v |> Seq.map (fun v -> value v) |> String.concat " | "
        let enumeration (v: Enumeration) = sprintf "%s = %s" v.Name (Enumeration.values v.Values)
        let enumerations (v: seq<Enumeration>) = sprintf "    type %s" (v |> Seq.map (fun v -> enumeration v) |> String.concat "\r\n    and ")
        let ``module`` (v: Module) = sprintf "module %s =%s%s" v.Name (if not (Seq.isEmpty v.Enumerations) then br + enumerations v.Enumerations else "") (if not (Seq.isEmpty v.Records) then br + records v.Records else "")
module Edi =
    open System.Collections.Generic
    type Element = { Value: string } with override r.ToString() = r.Value
    and Segment = { Name: string; Elements: seq<Element> } with override r.ToString() = Seq.append (Seq.singleton r.Name) (r.Elements |> Seq.map (fun b -> b.ToString())) |> String.concat "*"
    and Archive = { Segments: seq<Segment> } with override r.ToString() = r.Segments |> Seq.map (fun a -> a.ToString()) |> String.concat "~"
    let parse v =
        let segmentStarter = '~'
        let elementSplitter = '*'
        let getElements chars = seq {
            let r = List<char>()
            for c in chars do
                if c = elementSplitter then
                    yield { Value = String (r.ToArray()) }
                    r.Clear()
                else r.Add c
            yield { Value = String (r.ToArray()) } }
        let getSegments chars = seq {
            let v = if chars |> Seq.head = segmentStarter then chars |> Seq.skip 1 else chars
            let r = List<char>()
            for c in v do
                if '\r' = c || '\n' = c then () // Skip it
                elif c = segmentStarter then
                    let elements = getElements r
                    yield { Name = (elements |> Seq.head).Value; Elements = elements |> Seq.skip 1 }
                    r.Clear()
                else r.Add c
            let elements = getElements r
            yield { Name = (elements |> Seq.head).Value; Elements = elements |> Seq.skip 1 } }
        { Segments = getSegments v }
    let load file = parse (File.Text.readAll file)
    module Declaring =
        open System.Reflection
        type MustUse = M = 1 | MustUse = 2 | Optional = 3
        and ReqDes = M = 1 | O = 2
        and Usage = Mandatory = 1 | MustUse = 2 | Optional = 3
        and Level = Heading = 1 | Detail = 2 | Summary = 3
        and Segment(identifier, name, position, loop, level, usage, maxUse, purpose, syntaxNotes, semanticNotes, comments, notesExample, notesSegment) =
            inherit Attribute()
            member r.Identifier = identifier
            member r.Name = name
            member r.Position = position
            member r.Loop = loop
            member r.Level = level
            member r.Usage = usage
            //NOTE:-1表示大于1，-2表示大于2，于此类推.
            member r.MaxUse = maxUse
            member r.Purpose = purpose
            member r.SyntaxNotes = syntaxNotes
            member r.SemanticNotes = semanticNotes
            member r.Comments = comments
            member r.NotesExample = notesExample
            member r.NotesSegment = notesSegment
            static member isDefined (v: MemberInfo) = v.IsDefined (typeof<Segment>, false)
            static member get (v: MemberInfo) = v.GetCustomAttributes(typeof<Segment>, false).[0] :?> Segment
        and FieldAttribute(mustUse, positionNumber, segmentIdentifier, name, reqDes, maxUse) =
            inherit Attribute()
            member r.MustUse = mustUse
            member r.PositionNumber = positionNumber
            member r.SegmentIdentifier = segmentIdentifier
            member r.Name = name
            member r.ReqDes = reqDes
            member r.MaxUse = maxUse
        and DataElementSpecialAttribute = M = 1 | O = 2 | X = 3
        and DataElementAttribute(mustUse, refDes, dataElement, name, specialAttribute, attributes) =
            inherit Attribute()
            member r.MustUse = mustUse
            member r.RefDes = refDes
            member r.DataElement = dataElement
            member r.Name = name
            member r.SpecialAttribute = specialAttribute
            member r.Attributes = attributes;
        and LoopAttribute(name, loopRepeat) =
            inherit Attribute()
            member r.Name = name
            member r.LoopRepeat = loopRepeat
        type Maps(name) =
            inherit Attribute()
            member r.Name = name
            static member get (v:PropertyInfo) = if v.IsDefined(typeof<Maps>, false) then (v.GetCustomAttributes(typeof<Maps>, false).[0] :?> Maps).Name else v.Name
        and NotUsed() =
            inherit Attribute()
            static member isDefined (v: PropertyInfo) = v.IsDefined (typeof<NotUsed>, false)
    module LoadBuilder =
        open System.Reflection
        open Microsoft.FSharp.Reflection
        open Declaring
        let isNotDisabled p = not (NotUsed.isDefined p)
        let simpleConverts t = if t = typeof<int> then "int " elif t = typeof<int64> then "int64 " elif t = typeof<decimal> then "decimal " elif t = typeof<DateTime> then "parseShortDate " elif t.Name = "ReferenceIdentification" then "\"_\" + " else ""
        let complexConverts (t: Type) = if t.IsEnum then sprintf " |> Enum.parse typeof<%s> :?> %s" t.Name t.Name elif t.IsGenericType && t.GetGenericTypeDefinition() = typeof<Option<_>>.GetGenericTypeDefinition() then sprintf " |> (fun a -> if a <> \"\" then Some (Enum.parse typeof<%s> a :?> %s) else None)" (Mapping.CodeGereation.``type`` (t.GetGenericArguments().[0])) (Mapping.CodeGereation.``type`` (t.GetGenericArguments().[0])) else ""
//        let getValue v = sprintf "v.Current.Elements%s.First().Value" (if v = 0 then "" else sprintf ".Skip(%s)" (string v))
        let defaultValue t = if t = typeof<string> then "\"\"" elif t.IsGenericType && t.GetGenericTypeDefinition() = typeof<Option<_>>.GetGenericTypeDefinition() then "None" elif t = typeof<DateTime> then "DateTime.MinValue" else failwith ""
        let value (p: PropertyInfo) (i: int) = sprintf "%s = %s" p.Name (if isNotDisabled p then sprintf "%s(value v %i)%s" (simpleConverts p.PropertyType) i (complexConverts p.PropertyType) else defaultValue p.PropertyType)
        let values (a: Type) =
            let r = FSharpType.GetRecordFields a
            seq { for i = 0 to r.Length - 1 do yield value r.[i] i } |> String.concat "; "
        let buildSegmentLoader (a: Type) = sprintf "        let load%s (v: IEnumerator<Segment>) =\r\n            let r = if v.Current.Name = \"%s\" then { %s.%s } else raise FormatConfusingException\r\n            if v.MoveNext() then r else raise CannotMoveNextException" a.Name (Segment.get a).Identifier a.Name (values a)
        let build v = seq { for a in Assembly.GetExecutingAssembly().GetTypes() |> Seq.filter(fun a -> a.FullName.StartsWith (v + "+") && FSharpType.IsRecord a && Segment.isDefined a) do yield buildSegmentLoader a } |> String.concat br
